Sequential design with early stopping (restricted action set) - risk based
# Each input file corresponds to the results from a single simulation
# scenario/configuration.
# Load all the files into a single list.
# files of interest
sim_lab <- "sim05-13"
# files of interest
flist <- list.files(paste0("data/", sim_lab), pattern = "sim05")
toks <- list()
l <- list()
i <- 1
for(i in 1:length(flist)){
l[[i]] <- qs::qread(file.path(paste0("data/", sim_lab), flist[i]))
toks[[i]] <- unlist(tstrsplit(flist[i], "[-.]"))
}The results are from a simulated trial picked from scenario 4 where there is a moderate (OR 1.75) surgical revision effect in the two-stage domain only and all other domains having null treatment effects.
Table 1 shows the decisions made for each domain (or indeterminate if no decisions were made).
g_tbl <- d_decision |>
gt() |>
cols_align(
columns = 1:2,
align = "center"
) |>
cols_align(
columns = 3,
align = "right"
) |>
cols_label(
domain = "Domain",
decision = "Decision",
N = "Enrolment"
) |>
tab_options(
table.font.size = "70%"
) |>
fmt_number(decimals = 3, drop_trailing_zeros = TRUE)
g_tbl| Domain | Decision | Enrolment |
|---|---|---|
| 1 | Futile (sup) | 500 |
| 2 | NI | 500 |
| 3 | Futile (sup) | 1,000 |
| 4 | Futile (sup) | 2,000 |
Figure 1 shows the knowledge transitions based on the decisions made for each domain by sample size up to the point where the trial was stopped either due to running out of resources or having addressed all the questions.
Initially, all domains start in an indeterminate state in that neither treatment arm is preferred. As the data accrues and analyses progresses, the knowledge state for each domain may transition to, superiority, non-inferiority or futility.
Figure 2 through to Figure 5 show sample size for each domains.
Any decision rule only applies to the late acute silo (silo 2).
d_fig <- copy(d_dat_d1)
d_fig <- merge(
d_fig,
CJ(silo = 1:3, analys = 1:5, d1 = c("DAIR", "One-stage", "Two-stage")),
by = c("silo", "analys", "d1"),
all.y = T
)
d_fig[, cn := nafill(cn, type = "locf"), keyby = .(silo, d1)]
p_d1 <- ggplot(d_fig, aes(x = d1, y = cn)) +
geom_linerange(aes(ymin = 0, ymax = cn), lwd = 1) +
scale_x_discrete("") +
scale_y_continuous("Sample size", breaks = seq(0, 800, by = 200)) +
facet_grid(silo ~ analys, labeller = label_both) +
theme(text = element_text(size = 6),
strip.text.y.right = element_text(angle = 0, size = 6),
axis.text.x = element_text(angle = 45, vjust = 1, hjust=1, size = 6),
axis.text.y = element_text(size = 6))
suppressWarnings(print(p_d1))
Of those receiving one-stage (see figure for domain 1) and irrespective of silo membership, approximately 70% are assumed to enter the AB duration domain.
d_fig <- copy(d_dat_d2)
d_fig <- merge(
d_fig,
CJ(silo = 1:3, analys = 1:5, d2 = c("Selected", "12wk", "6wk")),
by = c("silo", "analys", "d2"),
all.y = T
)
d_fig[, cn := nafill(cn, type = "locf"), keyby = .(silo, d2)]
d_fig[, d2 := factor(
d2, levels = c("Selected", "12wk", "6wk"))]
p_d2_a <- ggplot(d_fig, aes(x = d2, y = cn)) +
geom_linerange(aes(ymin = 0, ymax = cn), lwd = 1) +
scale_x_discrete("") +
scale_y_continuous("Sample size") +
facet_grid(silo ~ analys, labeller = label_both) +
theme(text = element_text(size = 6),
strip.text.y.right = element_text(angle = 0, size = 6),
axis.text.x = element_text(angle = 45, vjust = 1, hjust=1, size = 6),
axis.text.y = element_text(size = 6))
d_fig <- copy(d_dat_d2)
d_fig <- d_fig[, .(cn = sum(cn)), keyby = .(analys, d2)]
d_fig <- merge(
d_fig,
CJ(analys = 1:5, d2 = c("Selected", "12wk", "6wk")),
by = c("analys", "d2"),
all.y = T
)
d_fig[, cn := nafill(cn, type = "locf"), keyby = .(d2)]
d_fig[, d2 := factor(
d2, levels = c("Selected", "12wk", "6wk"))]
p_d2_b <- ggplot(d_fig, aes(x = d2, y = cn)) +
geom_linerange(aes(ymin = 0, ymax = cn), lwd = 1) +
scale_x_discrete("") +
scale_y_continuous("Sample size") +
facet_grid(. ~ analys, labeller = label_both) +
theme(text = element_text(size = 6),
strip.text.y.right = element_text(angle = 0, size = 6),
axis.text.x = element_text(angle = 45, vjust = 1, hjust=1, size = 6),
axis.text.y = element_text(size = 6))
suppressWarnings(
grid.arrange(p_d2_a, p_d2_b, nrow = 2, heights = c(3, 1))
)
Of those receiving two-stage (see figure for domain 1) and irrespective of silo membership, approximately 90% are assumed to enter the AB ext-proph domain.
d_fig <- copy(d_dat_d3)
d_fig <- merge(
d_fig,
CJ(silo = 1:3, analys = 1:5, d3 = c("Selected", "none", "12wk")),
by = c("silo", "analys", "d3"),
all.y = T
)
d_fig[, cn := nafill(cn, type = "locf"), keyby = .(silo, d3)]
d_fig[, d3 := factor(
d3, levels = c("Selected", "none", "12wk"))]
p_d3_a <- ggplot(d_fig, aes(x = d3, y = cn)) +
geom_linerange(aes(ymin = 0, ymax = cn), lwd = 1) +
scale_x_discrete("") +
scale_y_continuous("Sample size") +
facet_grid(silo ~ analys, labeller = label_both) +
theme(text = element_text(size = 6),
strip.text.y.right = element_text(angle = 0, size = 6),
axis.text.x = element_text(angle = 45, vjust = 1, hjust=1, size = 6),
axis.text.y = element_text(size = 6))
d_fig <- copy(d_dat_d3)
d_fig <- d_fig[, .(cn = sum(cn)), keyby = .(analys, d3)]
d_fig <- merge(
d_fig,
CJ(analys = 1:5, d3 = c("Selected", "none", "12wk")),
by = c("analys", "d3"),
all.y = T
)
d_fig[, cn := nafill(cn, type = "locf"), keyby = .(d3)]
d_fig[, d3 := factor(
d3, levels = c("Selected", "none", "12wk"))]
p_d3_b <- ggplot(d_fig, aes(x = d3, y = cn)) +
geom_linerange(aes(ymin = 0, ymax = cn), lwd = 1) +
scale_x_discrete("") +
scale_y_continuous("Sample size") +
facet_grid(. ~ analys, labeller = label_both) +
theme(text = element_text(size = 6),
strip.text.y.right = element_text(angle = 0, size = 6),
axis.text.x = element_text(angle = 45, vjust = 1, hjust=1, size = 6),
axis.text.y = element_text(size = 6))
suppressWarnings(
grid.arrange(p_d3_a, p_d3_b, nrow = 2, heights = c(3, 1))
)
Across the entire trial sample, approximately 60% are assumed to enter the AB choice domain.
Here, we know there is an effect of AB choice and would hope that a decision for superiority is made such that new participants are directed to receive rifampacin.
d_fig <- copy(d_dat_d4)
d_fig <- merge(
d_fig,
CJ(silo = 1:3, analys = 1:5, d4 = c("Selected", "no-rif", "rif")),
by = c("silo", "analys", "d4"),
all.y = T
)
d_fig[, cn := nafill(cn, type = "locf"), keyby = .(silo, d4)]
d_fig[, d4 := factor(
d4, levels = c("Selected", "no-rif", "rif"))]
p_d4_a <- ggplot(d_fig, aes(x = d4, y = cn)) +
geom_linerange(aes(ymin = 0, ymax = cn), lwd = 1) +
scale_x_discrete("") +
scale_y_continuous("Sample size") +
facet_grid(silo ~ analys, labeller = label_both) +
theme(text = element_text(size = 6),
strip.text.y.right = element_text(angle = 0, size = 6),
axis.text.x = element_text(angle = 45, vjust = 1, hjust=1, size = 6),
axis.text.y = element_text(size = 6))
d_fig <- copy(d_dat_d4)
d_fig <- d_fig[, .(cn = sum(cn)), keyby = .(analys, d4)]
d_fig <- merge(
d_fig,
CJ(analys = 1:5, d4 = c("Selected", "no-rif", "rif")),
by = c("analys", "d4"),
all.y = T
)
d_fig[, cn := nafill(cn, type = "locf"), keyby = .(d4)]
d_fig[, d4 := factor(
d4, levels = c("Selected", "no-rif", "rif"))]
p_d4_b <- ggplot(d_fig, aes(x = d4, y = cn)) +
geom_linerange(aes(ymin = 0, ymax = cn), lwd = 1) +
scale_x_discrete("") +
scale_y_continuous("Sample size") +
facet_grid(. ~ analys, labeller = label_both) +
theme(text = element_text(size = 6),
strip.text.y.right = element_text(angle = 0, size = 6),
axis.text.x = element_text(angle = 45, vjust = 1, hjust=1, size = 6),
axis.text.y = element_text(size = 6))
suppressWarnings(
grid.arrange(p_d4_a, p_d4_b, nrow = 2, heights = c(3, 1))
)
Figure 6 and Figure 7 show the parameter estimates.
Note:
Parameter estimates will only be reported up until the simulated trial was stopped due to all questions having been answered.
Figure 6 shows the posterior odds-ratios for the randomised comparisons by domain and enrolment progression.
# late acute, surgical effects
d_d1_n <- d_dat[silo == 2,
.(n = sum(N), domain = 1), keyby = .(analys, d1)]
setnames(d_d1_n, "d1", "trt")
# those receiving one-stage and randomised treatment in domain 2
d_d2_n <- d_dat[d1 == 2 & d2 %in% 2:3,
.(n = sum(N), domain = 2), keyby = .(analys, d2)]
setnames(d_d2_n, "d2", "trt")
# those receiving two-stage and randomised treatment in domain 3
d_d3_n <- d_dat[d1 == 3 & d3 %in% 2:3,
.(n = sum(N), domain = 3), keyby = .(analys, d3)]
setnames(d_d3_n, "d3", "trt")
# those receiving randomised treatment in domain 4
d_d4_n <- d_dat[d4 %in% 2:3,
.(n = sum(N), domain = 4), keyby = .(analys, d4)]
setnames(d_d4_n, "d4", "trt")
d_n_trt <- rbind(
d_d1_n, d_d2_n, d_d3_n, d_d4_n
)
d_n_trt <- merge(
d_n_trt,
d_N[analys != 0],
by = "analys"
)
d_n_trt <- d_n_trt[, .(n = sum(n)), keyby = .(N, domain)]
d_n_trt[, n := cumsum(n), keyby = domain]
p1 <- ggplot(d_mod[par == "lor"], aes(x = N, y = exp(med))) +
geom_point() +
geom_linerange(aes(ymin = exp(q_025), ymax = exp(q_975)), lwd = 0.25) +
geom_text(
data = d_n_trt,
aes(x = N, y = -0.5, label = n), col = 2, size = 2
) +
scale_x_continuous("") +
scale_y_continuous("OR") +
facet_wrap(domain ~ ., labeller = label_both)
suppressWarnings(print(p1))
Figure 7 shows the posterior risk differences for the randomised comparisons by domain and enrolment progression.
Figure 8 shows the probability associated with each decision type for the randomised comparisons by domain and enrolment progression.
Note:
See example 1 for general explanation of plot.
d_fig_1 <- copy(d_pr_dec)
d_fig_1[, quant := factor(quant, levels = c("sup", "sup_fut", "ni", "ni_fut"),
labels = c("Superior", "Superior (futile)",
"NI", "NI (futile)"))]
d_fig_2 <- copy(d_dec_thres)
d_fig_2[, quant := factor(quant, levels = c("sup", "sup_fut", "ni", "ni_fut"),
labels = c("Superior", "Superior (futile)",
"NI", "NI (futile)"))]
d_fig_2 <- merge(
d_fig_2,
unique(d_fig_1[, .(domain, quant, question)]),
by = c("quant", "domain")
)
p1 <- ggplot(d_fig_1, aes(x = N, y = value)) +
geom_point(aes(col=quant), position = position_dodge2(width = 100), size = 0.6) +
geom_linerange(aes(ymin = 0, ymax = value, col=quant),
position = position_dodge2(width = 100), lwd = 0.25)+
geom_hline(
data = d_fig_2,
aes(yintercept = threshold, col=quant), lwd = 0.25
) +
scale_x_continuous("") +
scale_y_continuous("Decision probability", breaks = seq(0, 1, by = 0.2)) +
scale_color_discrete("") +
facet_wrap(domain ~ question, labeller = label_both)
suppressWarnings(print(p1))